home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / src-server / xlisp / unixstuff.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-10-04  |  13.0 KB  |  478 lines

  1. /* -*-C-*-
  2. ********************************************************************************
  3. *
  4. * File:         unixstuff.c
  5. * RCS:          $Header: unixstuff.c,v 1.9 91/03/24 22:23:52 mayer Exp $
  6. * Description:  UNIX-Specific interfaces for XLISP
  7. * Author:       David Michael Betz; Niels Mayer
  8. * Created:      
  9. * Modified:     Fri Oct  4 03:29:45 1991 (Niels Mayer) mayer@hplnpm
  10. * Language:     C
  11. * Package:      N/A
  12. * Status:       X11r5 contrib tape release
  13. *
  14. * WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  15. * XLISP version 2.1, Copyright (c) 1989, by David Betz.
  16. *
  17. * Permission to use, copy, modify, distribute, and sell this software and its
  18. * documentation for any purpose is hereby granted without fee, provided that
  19. * the above copyright notice appear in all copies and that both that
  20. * copyright notice and this permission notice appear in supporting
  21. * documentation, and that the name of Hewlett-Packard and David Betz not be
  22. * used in advertising or publicity pertaining to distribution of the software
  23. * without specific, written prior permission.  Hewlett-Packard and David Betz
  24. * make no representations about the suitability of this software for any
  25. * purpose. It is provided "as is" without express or implied warranty.
  26. *
  27. * HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
  28. * SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
  29. * IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
  30. * INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
  31. * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
  32. * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
  33. * PERFORMANCE OF THIS SOFTWARE.
  34. *
  35. * See ./winterp/COPYRIGHT for information on contacting the authors.
  36. * Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com
  37. * Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
  38. *
  39. ********************************************************************************
  40. */
  41. static char rcs_identity[] = "@(#)$Header: unixstuff.c,v 1.9 91/03/24 22:23:52 mayer Exp $";
  42.  
  43.  
  44. #include "xlisp.h"
  45.  
  46. #ifdef WINTERP
  47. #include <fcntl.h>        /* needed for fcntl(2) calls */
  48. #endif
  49.  
  50. /******************************************************************************
  51.  * Prim_POPEN - start a process and open a pipe for read/write 
  52.  * (code stolen from xlfio.c:xopen())
  53.  *
  54.  * syntax: (popen <command line> :direction <direction>)
  55.  *                <command line> is a string to be sent to the subshell (sh).
  56.  *                <direction> is either :input (to read from the pipe) or
  57.  *                                      :output (to write to the pipe).
  58.  *                                      (:input is the default)
  59.  *
  60.  * Popen returns a stream, or NIL if files or processes couldn't be created.
  61.  * The  success  of  the  command  execution  can be checked by examining the 
  62.  * return value of pclose. 
  63.  *
  64.  * Added to XLISP by Niels Mayer
  65.  ******************************************************************************/
  66. LVAL Prim_POPEN()
  67. {
  68.   extern LVAL k_direction, k_input, k_output;
  69.   char *name,*mode;
  70.   FILE *fp;
  71.   LVAL dir;
  72.  
  73.   /* get the process name and direction */
  74.   name = (char *) getstring(xlgastring());
  75.   if (!xlgetkeyarg(k_direction, &dir))
  76.     dir = k_input;
  77.   
  78.   /* get the mode */
  79.   if (dir == k_input)
  80.     mode = "r";
  81.   else if (dir == k_output)
  82.     mode = "w";
  83.   else
  84.     xlerror("bad direction",dir);
  85.   
  86.   /* try to open the file */
  87.   return ((fp = popen(name,mode)) ? cv_pipe(fp) : NIL);
  88. }
  89.  
  90.  
  91. /******************************************************************************
  92.  * Prim_PCLOSE - close a pipe opened by Prim_POPEN().
  93.  * (code stolen from xlfio.c:xclose())
  94.  *
  95.  * syntax: (pclose <stream>)
  96.  *                  <stream> is a stream created by popen.
  97.  * returns T if the command executed successfully, otherwise, 
  98.  * returns the exit status of the opened command.
  99.  *
  100.  * Added to XLISP by Niels Mayer
  101.  ******************************************************************************/
  102. LVAL Prim_PCLOSE()
  103. {
  104.   extern LVAL true;
  105.   LVAL fptr;
  106.   int  result;
  107.  
  108.   /* get file pointer */
  109.   fptr = xlga_pipe();
  110.   xllastarg();
  111.  
  112.   /* make sure the file exists */
  113.   if (getfile(fptr) == NULL)
  114.     xlfail("file not open");
  115.  
  116.   /* close the pipe */
  117.   result = pclose(getfile(fptr));
  118.  
  119.   if (result == -1)
  120.     xlfail("stream passed to pclose() has not been opened with popen()");
  121.     
  122.   setfile(fptr,NULL);
  123.  
  124.   /* return T if success (exit status 0), else return exit status */
  125.   return (result ? cvfixnum(result) : true);
  126. }
  127.  
  128.  
  129. /******************************************************************************
  130.  * Prim_SYSTEM - run a process, sending output (if any) to stdout/stderr
  131.  *
  132.  * syntax: (system <command line>)
  133.  *                 <command line> is a string to be sent to the subshell (sh).
  134.  *
  135.  * Returns T if the command executed succesfully, otherwise returns the 
  136.  * integer shell exit status for the command.
  137.  *
  138.  * Added to XLISP by Niels Mayer
  139.  ******************************************************************************/
  140. LVAL Prim_SYSTEM()
  141. {
  142.   extern LVAL true;
  143.   extern int sys_nerr;
  144.   extern char *sys_errlist[];
  145.   extern int errno;
  146.   LVAL command;
  147.   int  result;
  148.   char temptext[1024];
  149.  
  150.   /* get shell command */
  151.   command = xlgastring();
  152.   xllastarg();
  153.   
  154.   /* run the process */
  155.   result = system((char *) getstring(command));
  156.  
  157.   if (result == -1) {        /* if a system error has occured */
  158.     if (errno < sys_nerr)
  159.       (void) sprintf(temptext, "Error in system(3S): %s", sys_errlist[errno]);
  160.     else
  161.       (void) strcpy(temptext, "Error in system(3S): unknown error.");
  162.     xlfail(temptext);
  163.   }
  164.  
  165.   /* return T if success (exit status 0), else return exit status */
  166.   return (result ? cvfixnum(0xff & (result>>8)) : true);
  167. }
  168.  
  169.  
  170. /******************************************************************************
  171.  * (FSCANF-FIXNUM <stream> <scanf-format>)
  172.  * This routine calls fscanf(3s) on a <stream> that was previously openend
  173.  * via open or popen. It will not work on an USTREAM.
  174.  * <scanf-format> is a format string containing a single conversion
  175.  * directive that will result in an integer valued conversion.
  176.  * %d, %u, %o, %x, %ld, %lu, %lo and %lx style conversions 
  177.  * are acceptable for this routine.
  178.  * WARNING: specifying a <scanf-format> that will result in the conversion
  179.  * of a result larger than sizeof(long) will result in corrupted memory and
  180.  * core dumps. 
  181.  * 
  182.  * This routine will return an FIXNUM if fscanf() returns 1 (i.e. if
  183.  * the one expected conversion has succeeded. It will return NIL if the
  184.  * conversion wasn't successful, or if EOF was reached.
  185.  ******************************************************************************/
  186. LVAL Prim_FSCANF_FIXNUM()
  187. {
  188.   LVAL  lval_stream;
  189.   char* fmt;
  190.   long  result;
  191.   
  192.   lval_stream = xlgastream();
  193.   if (getfile(lval_stream) == NULL)
  194.     xlerror("File not opened.", lval_stream);
  195.   fmt = (char *) getstring(xlgastring());
  196.   xllastarg();
  197.   
  198.   result = 0L;            /* clear it out hibits incase short is written */
  199.   /* if scanf returns result <1 then an error or eof occured. */
  200.   if (fscanf(getfile(lval_stream), fmt, &result) < 1)
  201.     return (NIL);
  202.   else
  203.     return (cvfixnum((FIXTYPE) result));
  204. }
  205.  
  206.  
  207. /******************************************************************************
  208.  * (FSCANF-STRING <stream> <scanf-format>)
  209.  * This routine calls fscanf(3s) on a <stream> that was previously openend
  210.  * via open or popen. It will not work on an USTREAM.
  211.  * <scanf-format> is a format string containing a single conversion
  212.  * directive that will result in a string valued conversion.
  213.  * %s, %c, and %[...] style conversions are acceptable for
  214.  * this routine.
  215.  * WARNING: specifying a <scanf-format> that will result in the conversion
  216.  * of a result larger than 1024 characters will result in corrupted
  217.  * memory and core dumps.
  218.  * 
  219.  * This routine will return a string if fscanf() returns 1 (i.e. if
  220.  * the one expected conversion has succeeded. It will return NIL if the
  221.  * conversion wasn't successful, or if EOF was reached.
  222.  ******************************************************************************/
  223. LVAL Prim_FSCANF_STRING()
  224. {
  225.   LVAL lval_stream;
  226.   char* fmt;
  227.   char result[BUFSIZ];
  228.  
  229.   
  230.   lval_stream = xlgastream();
  231.   if (getfile(lval_stream) == NULL)
  232.     xlerror("File not opened.", lval_stream);
  233.   fmt = (char *) getstring(xlgastring());
  234.   xllastarg();
  235.   
  236.   result[0] = result[1] = '\0';    /* if the conversion is %c, then fscanf
  237.                    doesn't null terminate the string,
  238.                    so do it just incase */
  239.  
  240.   /* if scanf returns result <1 then an error or eof occured. */
  241.   if (fscanf(getfile(lval_stream), fmt, result) < 1)
  242.     return (NIL);
  243.   else
  244.     return (cvstring(result));
  245. }
  246.  
  247.  
  248. /******************************************************************************
  249.  * (FSCANF-FLONUM <stream> <scanf-format>)
  250.  * This routine calls fscanf(3s) on a <stream> that was previously openend
  251.  * via open or popen. It will not work on an USTREAM.
  252.  * <scanf-format> is a format string containing a single conversion
  253.  * directive that will result in an FLONUM valued conversion.
  254.  * %e %f or %g are valid conversion specifiers for this routine.
  255.  *
  256.  * WARNING: specifying a <scanf-format> that will result in the conversion
  257.  * of a result larger than sizeof(float) will result in corrupted memory and
  258.  * core dumps. 
  259.  * 
  260.  * This routine will return a FLONUM if fscanf() returns 1 (i.e. if
  261.  * the one expected conversion has succeeded. It will return NIL if the
  262.  * conversion wasn't successful, or if EOF was reached.
  263.  ******************************************************************************/
  264. LVAL Prim_FSCANF_FLONUM()
  265. {
  266.   LVAL lval_stream;
  267.   char* fmt;
  268.   FILE * fp;
  269.   float result;
  270.   
  271.   lval_stream = xlgastream();
  272.   if (getfile(lval_stream) == NULL)
  273.     xlerror("File not opened.", lval_stream);
  274.   fmt = (char *) getstring(xlgastring());
  275.   xllastarg();
  276.   
  277.   /* if scanf returns result <1 then an error or eof occured. */
  278.   if (fscanf(getfile(lval_stream), fmt, &result) < 1)
  279.     return (NIL);
  280.   else
  281.     return (cvflonum((FLOTYPE) result));
  282. }
  283.  
  284. /******************************************************************************/
  285. /******************************************************************************/
  286. /******************************************************************************/
  287. /* -- stuff.c  -- operating system specific routines */
  288. /* -- Written by dbetz for XLISP 2.0 */
  289. /* -- Copied by EFJohnson from a BIX message */
  290. /* -- Unix System V */
  291.  
  292. #define    LBSIZE    200
  293.  
  294. /* -- external variables */
  295. extern    FILE    *tfp;
  296.  
  297. /* -- local variables */
  298. static    long    rseed = 1L;
  299.  
  300. static    char    lbuf[LBSIZE];
  301. static    int    lindex;
  302. static    int    lcount;
  303.  
  304.  
  305. /* -- osinit - initialize */
  306. osinit(banner)
  307.  
  308. char    *banner;
  309. {
  310.     printf("%s\n", banner );
  311.     lindex    = 0;
  312.     lcount    = 0;
  313. }
  314.  
  315. /* -- osfinish - clean up before returning to the operating system */
  316. osfinish()
  317. {
  318. }
  319.  
  320.  
  321. /* -- oserror - print an error message */
  322. oserror(msg)
  323.  
  324. char    *msg;
  325.  
  326. {
  327.     printf( "error: %s\n", msg );
  328. }
  329.  
  330.  
  331. /* -- osrand - return a random number between 0 and n-1 */
  332. int osrand(n)
  333.  
  334. int    n;
  335.  
  336. {
  337.     long k1;
  338.  
  339.     /* -- make sure we don't get stuck at zero */
  340.     if ( rseed == 0L ) rseed = 1L;
  341.  
  342.     /* -- algorithm taken from Dr Dobbs Journal, Nov. 1985, page 91 */
  343.     k1 = rseed / 127773L;
  344.     if ( ( rseed = 16807L * (rseed - k1 * 127773L) -k1 * 2836L) < 0L )
  345.         rseed += 2147483647L;
  346.  
  347.     /* -- return a random number between 0 and n-1 */
  348.     return( (int) (rseed & (long) n ) );
  349. }
  350.  
  351.  
  352.  
  353. /* -- osaopen -- open an ascii file */
  354. FILE    *osaopen( name, mode )
  355. char    *name, *mode;
  356. {
  357. #ifdef WINTERP
  358.   FILE* fp = fopen(name, mode);
  359.   if (fp)
  360.     fcntl(fileno(fp), F_SETFD, 1); /* set close-on-exec */
  361.   return (fp);
  362. #else
  363.     return( fopen( name, mode ) );
  364. #endif /* WINTERP */
  365. }
  366.  
  367.  
  368.  
  369. /* -- osbopen -- open a binary file */
  370. FILE    *osbopen( name, mode )
  371. char    *name, *mode;
  372. {
  373. #ifdef WINTERP
  374.   FILE* fp = fopen(name, mode);
  375.   if (fp)
  376.     fcntl(fileno(fp), F_SETFD, 1); /* set close-on-exec */
  377.   return (fp);
  378. #else
  379.     return( fopen( name, mode ) );
  380. #endif    /* WINTERP */
  381. }
  382.  
  383.  
  384. /* -- osclose -- close a file */
  385. int    osclose( fp )
  386. FILE    *fp;
  387. {
  388.     return( fclose( fp ) );
  389. }
  390.  
  391.  
  392. /* -- osagetc - get a character from an ASCII file */
  393. int    osagetc( fp )
  394. FILE    *fp;
  395. {
  396.     return( getc(fp) );
  397. }
  398.  
  399. /* -- osaputc - put a character to an ASCII file */
  400. int    osaputc( ch, fp )
  401. int    ch;
  402. FILE    *fp;
  403. {
  404.     return( putc( ch, fp ) );
  405. }
  406.  
  407.  
  408.  
  409. /* -- osbgetc - get a character from a binary file */
  410. int    osbgetc( fp )
  411. FILE    *fp;
  412. {
  413.     return( getc(fp) );
  414. }
  415.  
  416. /* -- osbputc - put a character to a binary file */
  417. int    osbputc( ch, fp )
  418. int    ch;
  419. FILE    *fp;
  420. {
  421.     return( putc( ch, fp ) );
  422. }
  423.  
  424.  
  425. /* -- ostgetc - get a character from the terminal */
  426. int    ostgetc()
  427. {
  428.     while(--lcount < 0 )
  429.         {
  430.         if ( fgets(lbuf,LBSIZE,stdin) == NULL )
  431.             return( EOF );
  432.         if ( tfp )
  433.             fputs( lbuf, tfp );
  434.         lcount = strlen( lbuf );
  435.         lindex = 0;
  436.         }
  437.  
  438.     return( lbuf[lindex++] );
  439. }
  440.  
  441.  
  442. /* -- ostputc - put a character to the terminal */
  443. ostputc( ch )
  444. int    ch;
  445. {
  446.     /* -- check for control characters */
  447.     oscheck();
  448.     
  449.     /* -- output the character */
  450.     putchar( ch );
  451.  
  452.     /* -- output the char to the transcript file */
  453.     if ( tfp )
  454.         osaputc( ch, tfp );
  455. }
  456.  
  457.  
  458.  
  459.  
  460. /* -- osflush - flush the terminal input buffer */
  461. osflush()
  462. {
  463.     lindex = lcount = 0;
  464. }
  465.  
  466.  
  467. /* -- oscheck - check for control characters during execution */
  468. oscheck()
  469. {
  470. }
  471.  
  472.  
  473. /* -- ossymbols - enter os-specific symbols */
  474. ossymbols()
  475. {
  476. }
  477.